Shareware Grab Bag/Shareware Grab Bag.iso/095/tbbs105.arc/BBS2.INC

Text File | 1985-10-02 | 11.0 KB | 459 lines

procedure sysoponly;

  var temp: char;

  procedure readcomments;

    var
     comment: line;
     comfile: file of line;

    begin
      if cts then begin
        clearsc;
        assign(comfile, 'COMMENTS.BBS');
        {$I-} reset(comfile) {$I+};
        if IOresult <> 0 then rewrite(comfile);
        while cts and (not cancelled) and not eof(comfile) do begin
          read(comfile,comment);
          lineout(comment);
        end;
        if getcap('Kill (Y/N)? ') = 'Y' then rewrite(comfile);
        close(comfile);
        unload;
      end;
    end;

  procedure changelevel;

    var
     inch, number: integer;
     temp: name;

    begin
      repeat
        number := getid('User name? ');
        if number > 0 then begin
          str(idrec.acc:2, temp);
          lineout('Access:' + temp);
          inch := getint(5, 0, 'New level? ');
          idrec.acc := inch;
          reset(idfile);
          seek(idfile, number - 1);
          write(idfile, idrec);
          unload;
        end;
      until number = 0;
    end;

  begin
    repeat
      temp := getcap('? ');
      case temp of
        'C': readcomments;
        'L': changelevel;
        '!': printon := not printon;
      end;
    until not ((temp in ['C','L','!']) and cts);
  end;

procedure definecs;

  var
    ch: char;
    prompt: line;

  begin
    ch := null;
    while cts and not (ch in ['Q','Y']) do begin
      lineout('The following input is NOT echoed until CR (RETURN) is pressed!');
      prompt := 'Enter character(s) that will clear your screen (end with CR): ';
      controls := true;
      cs := getinput(prompt, 11, noecho);
      controls := false;
      clearsc;
      ch := getcap(cr + lf + 'Did that do it (Y/N/Quit)? ');
    end;
    if ch = 'Q' then cs := lnfd;
  end;

procedure definebs;

  begin
    repeat
      flush;
      controls := true;
      stringout('Type your backspace key: ');
      bs := charin(echo);
      controls := false;
      lineout(space);
    until not ((bs in [cr, tab, space, '0'..'9', 'A'..'Z', 'a'..'z']) and cts);
  end;

procedure setwidth;

  var temp: integer;

  begin
    repeat
      temp := getint(132, 0, 'Enter your terminal width (chars/line): ');
    until (temp in [0, 20..132]) or not cts;
    if temp <> 0 then width := temp;
  end;

procedure setvideo;

  var loop: byte;
      inch: integer;
      temp: name;

  function ctlchar(ch: char): name;

    begin
      if ch > #127 then ch := chr(ord(ch) and 127);
      case ch of
        null..#31   : ctlchar := '^' + chr(ord(ch) + 64);
        space..#126 : ctlchar := ch;
        #127        : ctlchar := '<DEL>';
      end;
    end;

  procedure dispcontrol(ch: char);

    begin
      if ch < #128 then stringout(ctlchar(ch))
        else stringout(ctlchar(ch) + '(with 8th bit set)');
    end;

  begin
    repeat
      clearsc;
      lineout('Terminal parameters:' + cr + lf);
      lineout('1 - Upper case only: ' + yn[caps]);
      lineout('2 - Line feeds sent: ' + yn[lf = lnfd]);
      lineout('3 - Prompt bell ON : ' + yn[bl = bell]);
      stringout('4 - Backspace char.: ');
      dispcontrol(bs);
      lineout(space);
      stringout('5 - Clear Screen   : ');
      for loop := 1 to length(cs) do dispcontrol(cs[loop]);
      lineout(space);
      str(width:3, temp);
      lineout('6 - Terminal width : ' + temp);
      lineout(space);
      inch := getint(6, 0, 'Enter number of parameter to change (0 to quit): ');
      case inch of
        1: caps := not caps;
        2: if lf = lnfd then lf := null else lf := lnfd;
        3: if bl = bell then bl := null else bl := bell;
        4: definebs;
        5: definecs;
        6: setwidth;
      end;
    until (inch = 0) or not cts;
    if cts then lineout('New definitions are saved by [G]oodbye command.');
  end;

procedure chat;

  var
    count  : byte;
    inch   : char;

  begin
    inch := null;
    clearsc;
    lineout('Entering chat mode: CTL-C aborts at any time.');
    lineout('Summoning Sysop...');
    flush;
    count := 1;
    repeat
      count := count + 1;
      charout(bell);
      delay(1000);
      if inready then inch := charin(noecho);
    until (count > 10) or (inch <> null);
    while cts and (inch <> abort) do begin
      inch := charin(echo);
      if inch = cr then sendout(lf);
    end;
  end;

procedure newpass;

  var
    temp   : name;
    prompt : line;

  begin
    repeat
      prompt := 'Enter the password you want on this system: ';
      password := allcaps(getinput(prompt, 14,noecho));
      prompt := cr + lf + 'Enter it again, to be sure: ';
      temp := allcaps(getinput(prompt, 14, noecho));
      if temp <> password then lineout('Passwords did not match.');
    until (temp = password) or not cts;
    lineout('New password is saved when the [G]oodbye command is executed.');
  end;

procedure listusers;

  var
    tempid: sysid;
    inch:   name;

  begin
    if cts then begin
      clearsc;
      reset(idfile);
      str(filesize(idfile):4, inch);
      lineout(inch + ' users registered.');
      while cts and not(eof(idfile) or cancelled) do begin
        read(idfile,tempid);
        if access = sysop then begin
          str(tempid.acc:1, inch);
          stringout(inch + '  ');
        end;
        lineout(tempid.user);
      end;
      unload;
    end;
  end;

procedure userlog;

  var
    call:   person;
    loop:   integer;

  begin
    if cts then begin
      clearsc;
      {$I-} reset(logfile) {$I+};
      if IOresult <> 0 then rewrite(logfile);
      while cts and (not cancelled) and not eof(logfile) do begin
        read(logfile,logrec);
        if logrec.who < 1 then call := ('Not on userlist')
          else call := getname(logrec.who);
        if clockin then for loop := length(call)+1 to 25 do call := call+space;
        stringout(call);
        if clockin then stringout(logrec.when + ' to ' + logrec.done);
        lineout(space);
      end;
      if access = sysop then begin
        if getcap('Kill (Y/N)? ') = 'Y' then rewrite(logfile);
      end;
      close(logfile);
      unload;
    end;
  end;

procedure enterpass;

  var
    temp:  name;
    tries: byte;

  begin
    tries := 0;
    lineout(space);
    repeat
      if tries > 0 then stringout('Incorrect - try again: ');
      tries := tries + 1;
      temp := allcaps(getinput('Enter your password: ', 14, noecho));
    until (temp = idrec.pass) or (tries = 3) or not cts;
    if (temp <> idrec.pass) then hangup;
  end;

procedure getdefaults;

  begin
    enterpass;
    if cts then begin
      with idrec do begin
        password := pass;
        expert := (exfl = 0);
        access := acc;
        cs := clr;
        bs := bsp;
        lf := lnf;
        caps := upc;
        width := wid;
        lastmess := lstm;
        if clockin then lineout('Last on: ' + lsto);
      end;
    end;
  end;

procedure introduce;

  begin
    lineout(cr + lf + 'Getting new user password & terminal info:');
    if cts then begin
      newpass;
      setvideo;
      if caller = 'SYSOP' then access := sysop else access := newuser;
    end;
  end;

procedure signon(var caller: person);

  var ch: char;
      tries: byte;

  begin
    ch := space;
    tries := 0;
    repeat
      tries := tries + 1;
      repeat
        caller := allcaps(getinput('What is your full name? ', 28, echo));
      until (length(caller) > 4) or not cts;
      if cts then begin
        usernum := findid(caller);
        if (local or openBBS) and (usernum=0) then
          ch:=getcap(caller + ': is this correct (Y/N)? ');
      end;
      if (tries >= 3) and (usernum=0) and not openBBS then hangup;
    until (usernum > 0) or (ch = 'Y') or not cts;
    if cts then begin
      if usernum = 0 then introduce else getdefaults;
      dispcaller;
      if access = twit then begin
        lineout('User ' + caller + ' has been denied system access.');
        hangup;
      end;
    end;
  end;

procedure logcall;

  begin
    {$I-} reset(logfile) {$I+};
    if IOresult <> 0 then rewrite(logfile);
    seek(logfile, filesize(logfile));
    with logrec do begin
      who := usernum;
      if clockin then begin
        when := timeon;
        done := timeoff;
      end;
    end;
    write(logfile, logrec);
    close(logfile);
  end;

procedure endcall;

  begin
    if clockin then begin
      clock(offmonth, offdate, offhour, offmin, offsec);
      timeoff := time(offmonth, offdate, offhour, offmin, offsec);
    end;
    logcall;
  end;

procedure readmine;

  begin
    if cts and (usernum > 0) then begin
      lineout('Checking for your mail...');
      messagesearch(1,0,usernum,0);
    end;
  end;

procedure relog;

  begin
    endcall;
    if clockin then begin
      clock(onmonth, ondate, onhour, onmin, onsec);
      timeon := time(onmonth, ondate, onhour, onmin, onsec);
    end;
    signon(caller);
    status;
    readmine;
  end;

procedure apply;

  begin
    outfile(applying);
    getcomments(4);
  end;

procedure command;

  var
    prompt: line;
    inch  : char;
    first : boolean;

  begin
    first := true;
    while cts do begin
      if first and not expert then outfile(mainmenu);
      unload;
      prompt := cr + lf + 'Command: ';
      if not expert
        then prompt := prompt + 'A,B,C,E,F,G,H,I,K,L,M,N,O,P,R,S,U,W,X,Y,# ? '
        else prompt := prompt + '(? for menu) ? ';
      flush;
      inch := getcap(prompt);
      first := true;
      case inch of
        'A': apply;
        'B': outfile(bulletin);
        'C': chat;
        'E': enter;
        'F': filesys;
        'G': disconnect;
        'H': outfile(helpfile);
        'I': setvideo;
        'K': deletex;
        'L': userlog;
        'M': outfile(meetings);
        'N': messagesearch(findfirst(lastmess + 1), 0, 0, 0);
        'O': outfile(otherBBS);
        'P': newpass;
        'Q': relog;
        'R': receive;
        'S': quickscan;
        'U': listusers;
        'W': outfile(welcome);
        'X': begin expert := not expert; first := false; end;
        'Y': outfile(sysinfo);
        '#': begin status; showtime; connecttime; first := false; end;
        '?': if expert then outfile(mainmenu);
        '@': if access=sysop then sysoponly else first := false;
        '!': if access=sysop then printon := not printon else first := false;
        else first := false;
      end; {case}
    end; {while cts}
  end; {command}

procedure defaults;

  begin
    lf := lnfd;
    bl := null;
    cs := lnfd;
    bs := bksp;
    expert := false;
    caps := false;
    width := 80;
    access := newuser;
    assign(idfile, 'IDS.BBS');
    assign(logfile, 'LOG.BBS');
    lastmess := 0;
    caller := space;
    usernum := 0;
    messopen := false;
    filesopen := false;
    printon := false;
    inbuffer := '';
    cancelled := false;
    controls := false;
  end;